The X-Philes (2nd Revision)/The X-Philes Number 1 (1995).iso/xphiles/hp48hor1/tetris3.src

Text File | 1991-05-29 | 10KB | 554 lines

%%HP: T(3)A(D)F(.);
@ TETRIS3, by Andrey Dolgachev
DIR
  SETUP
    \<<
      IFERR ASC\->
      THEN XFIG
ASC\-> 'XFIG' STO
TFIG ASC\-> 'TFIG'
STO DISS ASC\->
'DISS' STO PIC1
ASC\-> 'PIC1' STO
PIC2 ASC\-> 'PIC2'
STO 'SETUP' PURGE
      ELSE
"Please make sure that
ASC\-> is in or above
this directory level."
1 DISP INFLP
      END
    \>>
  start
    \<< LCD\-> PREP
SWAP DEPTH 'L' STO
IFERR TETRIS THEN
    END "" 3 DISP
"" 4 DISP DEPTH L -
DROPN 3 DISER STOF
"" 'SAV' STO
    IF DLST 4 GET
    THEN PNTS
"Points" \->TAG LINS
"Lines" \->TAG LVL
"Level" \->TAG
    END
  \>>
RESU
  \<< IFERR LCD\-> PREP
SWAP DEPTH 'L' STO
MKSCR SAV LIST\->
DROP PICT SWAP {
# 43d # 0d } SWAP
REPL CONT THEN
"Game is not paused.
Press START to start
a new game."
3 DISP DROP INFLP
  END
\>>
              ABOUT
\<< PREP CLLCD
"   - Tetris3.0 by -
   Andrey Dolgachev
     - Credits -
Erik Bryntse for the
original HP48 version.
Joe Ervin for the
Screen Dissolve code."
1 DISP INFLP STOF
\>>
              HELP
\<< PREP CLLCD
"RESU   - Resume paused
         game

HIGH   - Show Top 5

CONFIG - Personalize
         your Tetris"
1 DISP INFLP CLLCD
"      DURING GAME

N - Draw Next
O - Off       8 - Flip
P - Pause   4,6 - R,L
Q - Quit      0 - Drop
K - Up a level"
1 DISP INFLP STOF
\>>
              HIGH
\<< LCD\-> PREP SWAP
DUP PICT SWAP {
# 0d # 0d } SWAP
REPL { # 0d # 0d }
PVIEW DRHI 3 DISER
STOF
\>>
              CONFIG
\<< PREP CLLCD
"There are three
dissolve sequences.
Enter the appropriate
codes next screen.
A 0 means no dissolve,
1 is bit-wise,
2 is tiling effect."
1 DISP INFLP
"Enter the diss. codes"
{ ":1:1
:2:1
:3:1"
{ -1 4 } } INPUT
OBJ\->
"Do you want your score
to be left on the
stack? (0/1)"
{ "1" -1 } INPUT
OBJ\->
"Enter your starting
level (0-9)"
{ "0" -1 } INPUT
OBJ\-> 5 \->LIST 'DLST'
STO
"Do you want your high
scores erased? (0/1)"
{ "0" -1 } INPUT
  IF "1" ==
  THEN Erase
  END STOF
\>>
              Erase
\<< { 0 "" 0 } DUP
DUP2 DUP 5 \->LIST
'SCORES' STO
\>>
              DLST
{ :1: 1 :2: 1 :3: 1
1 0 }
              RK2
\<<
  IF KEY
  THEN
    IF { 25 72 74
92 63 34 35 33 32 }
SWAP POS DUP
    THEN {
      \<<
        IF LVL 9 <
        THEN 'LVL'
INCR GETLV SHLV
        END
      \>>
      \<< # 1d NEG
MSIDE
      \>>
      \<< # 1d MSIDE
      \>> DROPIT ROTF
      \<< PICT {
# 43d # 0d } {
# 84d # 60d } SUB
DEPTH L - \->LIST
'SAV' STO 3 DISER
STOF HALT
      \>>
      \<< 3 SF
      \>> OFF
      \<< 7 FC?C
        IF
        THEN 7 SF
SHNP
        ELSE ERNP
        END
      \>> } SWAP GET
EVAL
    ELSE DROP
    END
  END
\>>
              PREP
\<< RCLF -40 CF STD
64 STWS # 131d
# 64d PDIM
\>>
              PNTS
11
              LINS
0
              LVL 0
              XFIG  @ by Erik Bryntse.  Decode with ASC->
"CCD204410034E7507137143818F8E1358BE60691117E818F328FB97601CE1B56
507146134152739E1B20F880029916912014313234E4A201428A2606EB016915
271011741431321428A63E16915271001741431321428A68C1691567AFAAF122
A95118C9AF5BF522A8520A8181D22A82C1201B56507146818F29818F29C91341
19BF2BF2241542BF616F16F1610D880BEBF4BF4BF4AF68AA60688F208F2D7601
42164808CE7C9"
              TFIG  @ By Erik Bryntse.  Decode with ASC->
"CCD20E310013606DD061B97507142137135818F098BA606FF014713481AF0914
234E4A208A26060E01691527100E717414381AF2914581AF291321428A26060B
01691567AFAAF1D122A95118C9D5F522A8520A81819F122A82C1201B56507146
818F29818F29C9136AF2156090A90B456E002F308200E49BF4BF4BF4AF68AE09
AF0AF2AC48108087340E68084396840E614313216915472007DD071361421648
08C3CA6"
              DISS  @ by Joe Ervin.  Decode with ASC->
"D9D20D4881D8A812BF8170140D9D208813026AC130A503223030A50322301192
004000A3D36D9D2044230C2A207200094E66716C69646027425F424024416471
6933A1B21301192038000A3D36D9D2044230C2A207200094E66716C696460274
25F4240244164716933A1B2130F7815322301192004000A3D36D9D2044230C2A
207200094E66716C696460205943445023596A756933A1B21301192038000A3D
36D9D2044230C2A207200094E66716C696460205943445023596A756933A1B21
3032230AEC8111920F780032230CCD20851008F14660AF38A850B478F14660AF
2DE109143818F09818F0981AF02174E78FB97601F56507147818F29818F2981A
F08AF234FFF3094B9034FFF00D7AF0103104AF2311194B6031F0AE581AF13777
011CC6C6114C2818F220EF781AF0C81AF0B94F92819F2819F281AF0B81961AE4
80863A080857AE881AF1181AF1B8B280DE721081AF148AC298D3415081AF1AC2
135AF014B0E6011B13381AF10C213313514FBED0E650E6ABED15D001B2130B21
309C7D"
              PIC1
"E1B20FF0008100022000FFFFFF3000FFFFFF3000308300300010830020000083
0000000083000000008300000000830000000083000000008300000000830000
0000830000000083000000008300000000830000000083EFCF3000836CC63000
8368462000836006000083E706000083600600008368060000836C060000C7EF
0F00D0FE"
              PIC2
"E1B20FF000810002200000008FFF3000008FFF30000083003000008100200000
8100000000810000000081000000008100000000810000000081000000008100
00000087000000008FFF300000000C300000000030E7E700003036C300003016
810000303681000030E7810000308681800030C68181083066C38FFF3037E78F
FF3002D5"
              TETRIS
\<< DLST 5 GET GETLV
3 CF 7 CF RAND 7 *
IP 1 + 'NPC' STO 0
'PNTS' STO 0 'LINS'
STO 0 'LVL' STO
MKSCR
  DO delay FLST NPC
RAND 7 * IP 1 +
'NPC' STO SHNP DUP
'OB1' STO GET 1 DUP
'OB2' STO GET # 12d
# 256d - 1 CF 0
'CP' STO
    DO RK2 RK2 RK2
RK2 a WAIT
      IF 1 FC?
      THEN
        IF 3 FC?
        THEN DUP2
# 0d XFIG # 256d +
DUP2 # 0d + TFIG
          IF # 0d
==
          THEN DUP2
# 63903d XFIG 'CP'
INCR DROP
          ELSE
# 256d - # 63903d
XFIG # 0d
          END
        END
      END
    UNTIL DUP # 0d
== 3 FS? OR
    END
    IF 3 FC?
    THEN CALP ADDP
DROP PACK MEM DROP
    END
  UNTIL FULL 3 FS?
OR
  END FIN
\>>
              FULL
\<<
# 72356802986000645d
# 522d DUP2 # 0d +
TFIG ROT ROT # 5d +
TFIG + # 0d >
\>>
              P2
\<< 1 ADDL DUP
# 3840d AND SRB 4 *
3 + # 43d SWAP 2
\->LIST PICT SWAP {
# 83d # 8d } SUB
PICT { # 43d # 12d
} ROT REPL
\>>
              PACK
\<< # 3338d
  DO TLIN
    IF # 4d ==
    THEN P2
    ELSE # 256d -
    END
  UNTIL DUP # 512d
<
  END DROP
\>>
              TLIN
\<< DUP
# 72356802986000645d
SWAP DUP2 # 0d +
TFIG ROT ROT # 5d +
TFIG +
\>>
              FLST
{ {
# 17802707620356d
# 279242096899d
# 35399189680388d
# 279242096901d } {
# 17802707620357d
# 279242097155d
# 17806986854917d
# 279242096645d } {
# 17802707620355d
# 206226604548d
# 17944425808389d
# 279242097157d } {
# 17802708664837d
# 279241044483d } {
# 35399188627717d
# 210504794628d } {
# 52926935483141d
# 279242097412d } {
# 206226600196d } }
              DROPIT
\<< 1 SF
  DO DUP2 # 0d XFIG
# 256d + DUP2 # 0d
+ TFIG
    IF # 0d \=/
    THEN # 256d -
# 63903d XFIG # 0d
    END
  UNTIL DUP # 0d ==
  END
\>>
              MSIDE
\<< \-> CD
  \<< DUP2 # 0d XFIG
CD + DUP2 # 0d +
TFIG
    IF # 0d \=/
    THEN CD -
    END DUP2
# 63903d XFIG
  \>>
\>>
              ROTF
\<< DUP2 # 0d XFIG
FLST OB1 GET OB2 1
-
  IF DUP 0 \<=
  THEN DROP DUP
SIZE
  END DUP \-> OS2
  \<< GET SWAP DUP2
# 0d + TFIG
    IF # 0d ==
    THEN ROT DROP
OS2 'OB2' STO
    ELSE SWAP DROP
    END DUP2
# 63903d XFIG
  \>>
\>>
              OB1 5
              OB2 1
              PPAR
{ (-6.5,-3.1)
(6.5,3.2) X 0 (0,0)
FUNCTION Y }
              GTNP
\<< \-> i
  \<< FLST i GET 1
GET
    CASE i 6 ==
      THEN # 2068d
      END i 7 ==
      THEN # 2580d
      END i 6 <
      THEN # 2324d
      END
    END
  \>>
\>>
              SHNP
\<<
  IF 7 FS?
  THEN ERNP NPC
GTNP # 63903d XFIG
  END
\>>
              ERNP
\<< PICT { # 86d
# 34d } # 22d # 17d
BLANK REPL
\>>
              NPC 5
              L 2
              SAV
""
              GETLV
\<< 10 SWAP - .04 *
DUP 'a' STO 'b' STO
\>>
              CALP
\<< LVL 2 * 24 + CP -
  IF 7 FS?
  THEN .75 * IP
  END
\>>
              delay
\<< b .004 - DUP
  IF 0 \<=
  THEN .004 DUP 'a'
STO 'b' STO DROP
  ELSE
    IF DUP .04 MOD
0 ==
    THEN DUP 'a'
STO 'LVL' INCR SHLV
    END 'b' STO
  END
\>>
              CP 8
              a .4
              b
.392
              MKSCR
\<< DUP ERASE PICT {
# 91d # 38d } PIC2
REPL (-6.5,3.2)
(6.5,-3.1) BOX
(-2.2,3.2)
(1.9,-2.8) BOX
(-6.5,1.8)
(6.5,1.6) BOX 1.5
1.1
  FOR I -6.5 I R\->C
6.5 I .1 - R\->C BOX
-.2
  STEP PICT { # 3d
# 38d } PIC1 REPL
PICT { # 44d # 0d }
# 40d # 60d BLANK
REPL PICT { # 95d
# 2d } "LINES :" 1
\->GROB REPL PICT {
# 2d # 2d }
"SCORE :" 1 \->GROB
REPL PICT { # 91d
# 28d } "NEXT" 1
\->GROB REPL PICT {
# 7d # 28d }
"LEVEL :" 1 \->GROB
REPL 0 ADDP 0 ADDL
SHLV PICT RCL SWAP
PICT SWAP { # 0d
# 0d } SWAP REPL {
# 0d # 0d } PVIEW 1
DISER
\>>
              DISER
\<< DLST SWAP GET
DTAG
  IF DUP 0 ==
  THEN DROP ERASE
PICT SWAP { # 0d
# 0d } SWAP REPL
  ELSE 1 - SWAP
DISS
  END
\>>
              INFLP
\<< 0 WAIT DROP
\>>
              ADDL
\<< 'LINS' STO+ PICT
{ # 100d # 8d }
LINS 1 \->GROB REPL
\>>
              ADDP
\<< 'PNTS' STO+ PICT
{ # 5d # 8d } PNTS
1 \->GROB REPL
\>>
              SHLV
\<< PICT { # 37d
# 28d } LVL 1 \->GROB
REPL
\>>
              FIN
\<< SCORES 5 GET CHHS
  IF
  THEN HI
  END DRHI
\>>
              HI
\<< 4 \-> I
  \<<
"CONGRATS, YOU REACHED
THE TOP FIVE"
{ "" \Ga } INPUT
ERASE LCD\-> PICT
SWAP { # 0d # 0d }
SWAP REPL { # 0d
# 0d } PVIEW PNTS
SWAP LINS 3 \->LIST
    DO
      IF I 0 ==
      THEN 0
      ELSE SCORES I
GET CHHS
      END
      IF
      THEN -1 'I'
STO+ 0
      ELSE SCORES 1
I SUB SWAP 1 \->LIST
+ SCORES I 1 + 4
SUB + 'SCORES' STO
1
      END
    UNTIL
    END
  \>>
\>>
              DRHI
\<< -.8 1.9 -6 -2.5
4.5 \-> N Y X1 X2 X3
  \<< # 131d # 64d
BLANK "HIGH SCORES"
3 \->GROB (-3.2,3.1)
SWAP REPL "SCORE"
-6.3 Y DRSC "NAME"
-1.1 Y DRSC "LINES"
3.5 Y DRSC 1 5 -.2
'Y' STO+
    FOR I N 'Y'
STO+ SCORES I GET
LIST\-> DROP 4 ROLL
SWAP X3 Y DRSC SWAP
X2 Y DRSC SWAP X1 Y
DRSC
    NEXT 2 DISER
INFLP
  \>>
\>>
              DRSC
\<< R\->C SWAP 2 \->GROB
REPL
\>>
              CHHS
\<< 1 GET PNTS <
\>>
              SCORES
{ { 0 "" 0 } { 0 ""
0 } { 0 "" 0 } { 0
"" 0 } { 0 "" 0 } }
            END